home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
progjour
/
1988
/
06
/
fcode
/
update.for
< prev
Wrap
Text File
|
1987-11-12
|
62KB
|
1,890 lines
PROGRAM UPDATE
C
C Revision Author: M. Steven Baker
C Revision Date: August 11, 1986
C
C Revised for RM Fortan on PC
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMPILER DEPENDENT
C---
C--- ENDER ERDEM LAWRENCE BERKELEY LABORATORY 1981
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
C---
OPEN( UNIT=INPUT , FILE='INPUT.TMP' , STATUS='old' )
OPEN( UNIT=OUTPUT, FILE='OUTPUT.' , STATUS='UNKNOWN')
C . , ACCESS='APPEND' )
OPEN( UNIT=OLDPL , FILE='OLDPL.TMP' , STATUS='UNKNOWN' )
OPEN( UNIT=NEWPL , FILE='NEWPL.TMP' , STATUS='UNKNOWN' )
OPEN( UNIT=COMPIL, FILE='COMPIL.TMP', STATUS='UNKNOWN' )
OPEN( UNIT=EDTT , FILE='EDTT.TMP' , STATUS='UNKNOWN' )
C . , FORM='UNFORMATTED' )
OPEN( UNIT=PL1TMP, FILE='PL1TMP.TMP', STATUS='UNKNOWN' )
C . , buffercount=8 , dispose='delete' )
OPEN( UNIT=PL2TMP, FILE='PL2TMP.TMP', STATUS='UNKNOWN' )
C . , buffercount=8 , dispose='delete' )
PLTMP = PL1TMP
C------ CK OLDPL
REWIND OLDPL
C>>>>>>>> *EOF* <<<<<<<<
READ( OLDPL, 1001, END=200 )
1001 FORMAT( 20A4 )
GOTO 300
C------ CREATION RUN .
200 WRITE(OUTPUT,1011)
1011 FORMAT(46H1U P D A T E C R E A T I O N L I S T I N G//)
CALL CREATE ( PLTMP, ERRCRT )
GOTO 500
C------ UPDATE RUN .
300 WRITE(OUTPUT,1012)
1012 FORMAT(50H1U P D A T E C O R R E C T I O N L I S T I N G//)
PLIN = OLDPL
CALL OPLRD
400 CALL CORRD
IF( ERRFLG .NE. 0 ) CALL ERROR ( 99 )
CALL CORECT
C------ CK IF MORE *ID
500 WRITE(OUTPUT,1013)
1013 FORMAT( /,1X,90(1H-),// )
520 IF( ERRFLG .NE. 0 ) CALL ERROR ( 99 )
PLIN = PLTMP
PLTMP = PL1TMP
IF( PLIN .EQ. PL1TMP ) PLTMP = PL2TMP
ENDFILE PLIN
REWIND PLTMP
ENDFILE PLTMP
REWIND PLIN
REWIND PLTMP
IF( RESEQF .EQ. 0 ) GOTO 570
CALL RESEQ
RESEQF = 0
GOTO 520
570 IF( BKSPFL .NE. 0 ) GOTO 400
CALL WNEWPL
IF( ERRFLG .NE. 0 ) CALL ERROR ( 99 )
END
SUBROUTINE A1A4 ( I1, I4, N )
C---
C--- PACK 4*N WORDS OF A1 FORMAT IN I1 INTO N WORDS OF A4 FORMAT IN I4
C---
DIMENSION I1(80), I4(20)
LOGICAL*1 L1(4), L4(4)
EQUIVALENCE ( ITEMP, L1(1) ), ( JTEMP, L4(1) )
J = 0
DO 200 I = 1 , N
DO 100 K = 1 , 4
J = J + 1
ITEMP = I1(J)
L4(K) = L1(1)
100 CONTINUE
I4(I) = JTEMP
200 CONTINUE
RETURN
END
SUBROUTINE A4A1 ( I4, I1, N )
DIMENSION I4(20), I1(80)
LOGICAL*1 L4(4), L1(4)
EQUIVALENCE ( IT, L4(1) ), ( J1, L1(1) )
DATA ISPACE/4H /
J = 0
DO 2 I = 1 , N
IT = I4(I)
DO 1 K = 1 , 4
J1 = ISPACE
L1(1) = L4(K)
J = J + 1
I1(J) = J1
1 CONTINUE
2 CONTINUE
RETURN
END
BLOCK DATA
C---
C---
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /OPTBL/ OPTBL(5,11), NOPTBL, JOP, OPARG
C---
DATA MSYMTB /400/
DATA MDIRLS/2000/
1 , MCORTB/1000/
2 , MMODLS/1000/
3 , MMEM /20000/
C-
DATA LINCNT /0/, BKSPFL /0/
C-
DATA STAR, BLNK, COMA, PERD, SLAS
1 /1H* , 1H , 1H, , 1H. , 1H/ /
C-
DATA NCOMDK, NDECK, NIDENT, NDIRLS, NSYMTB /5*0/
C-
DATA INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP
2 / 1 , 6 , 2 , 3 , 4
3 , 10 , 11 , 12 /
C-
DATA FULFLG/1/,RESEQF/0/,PRECOF/0/,NPLFLG/1/,ERRFLG/0/
1 , WARNFL/0/
DATA SHOWFL/1/
C-
DATA NOPTBL/11/
DATA OPTBL /4HD ,4HDELE,4HTE , 9,-2,
1 4HI ,4HINSE,4HRT ,10,-1,
2 4HCA ,4HCALL,4H , 2, 1,
3 4HCD ,4HCOMD,4HECK , 4, 1,
4 4HDK ,4HDECK,4H , 3, 1,
5 4HID ,4HIDEN,4HT , 1, 1,
6 4HAF ,4HADDF,4HILE ,11, 2,
7 4HPC ,4HPREC,4HOMP , 7, 0,
8 4HW ,4HWEOF,4H , 5, 0,
9 4HPA ,4HPART,4HIAL , 8, 0,
1 4HS ,4HSEQU,4HENCE, 6, 0/
C---
END
SUBROUTINE CALINP ( DKFL, ISYM, ERR )
C---
C--- PROCESS *CA INPUT
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
ERR = 0
IF( DKFL .EQ. -1 ) GOTO 8009
IF( ID1(2) .EQ. -1 ) GOTO 8800
IF( ID1(1) .EQ. BLNK ) GOTO 8007
CALL SYMSRC ( ID1, ISYM )
IF( ISYM .EQ. 0 ) GOTO 8010
IF( SYMTB(3,ISYM) .NE. -1 ) GOTO 8011
9000 RETURN
C------ NAME MISSING
8007 CALL ERROR ( 7 )
GOTO 8800
C------ CAN*T CALL FROM A COMDECK
8009 CALL ERROR ( 9 )
GOTO 8800
C------ COMDECK NOT FOUND
8010 CALL ERROR ( 10 )
GOTO 8800
C------ CAN*T CALL A DECK
8011 CALL ERROR ( 11 )
8800 ERR = 1
ISYM = 0
GOTO 9000
END
SUBROUTINE CARDRD ( CREAT )
C
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMPILER DEPENDENT
C-
C--- READ ONE LINE OF CORRECTION INPUT
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /CURRID/ IDFL
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DATA SHOW1/4H*/ */, SHOW2/4HSHOW/, SHOW3/4HNOSH/
C---
1001 FORMAT( 20A4 )
1002 FORMAT( 1X,I7,1H.,20A4 )
1015 FORMAT( 1X,2H//,I5,1H.,20A4 )
1016 FORMAT( 1X,2H..,I5,1H.,20A4 )
C---
CALFLG = 0
IF( BKSPFL .EQ. 0 ) GOTO 300
DO 240 I = 1 , 20
240 CARD4(I) = CARD4S(I)
GOTO 340
C>>>>>>>>> *EOF* <<<<<<<<<
300 READ( INPUT, 1001, END=700 ) CARD4
LINCNT = LINCNT + 1
340 CALL A4A1 ( CARD4(1), CARD(1), 1 )
DO 302 I = 1 , 20
I2 = 21 - I
IF( CARD4(I2) .NE. BLNK ) GOTO 304
302 CONTINUE
304 CONTINUE
OP = 0
IF( CARD(1) .NE. STAR ) GOTO 600
IF( CARD(2) .NE. SLAS ) GOTO 400
IF( (CARD4(1).EQ.SHOW1) .AND. (CARD4(2).EQ.SHOW2) )
9 SHOWFL = 1
IF( (CARD4(1).EQ.SHOW1) .AND. (CARD4(2).EQ.SHOW3) )
9 SHOWFL = 0
WRITE( OUTPUT, 1016 ) LINCNT, (CARD4(I), I=1,I2)
GOTO 300
400 CALL A4A1 ( CARD4(2), CARD(5), 19 )
CALL OPGET
IF( OP .EQ. 0 ) GOTO 600
TYP = OP
IF( (BKSPFL .NE. 0) .OR. (OP .EQ. 1) ) GOTO 900
WRITE( OUTPUT, 1015 ) LINCNT, (CARD4(I), I=1,I2)
GOTO 900
600 TYP = 1
IF( CREAT .NE. 0 ) GOTO 900
WRITE( OUTPUT, 1002 ) LINCNT, (CARD4(I), I=1,I2)
900 BKSPFL = 0
RETURN
700 OP = 99
GOTO 900
END
SUBROUTINE COMPWT ( REC )
C---
C--- WRITE ONE LINE OF COMPILE FILE
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
C---
DIMENSION REC(22), NM(2), LINE1(20), LINE2(20)
C---
J = REC(1)
NM(1) = SYMTB(1,J)
NM(2) = SYMTB(2,J)
IF(PRECOF .EQ. 0) GOTO 10
CALL PRECMP(REC(3),LINE1,LINE2,NL)
IF( PRECOF .EQ. 0 ) GOTO 10
IF( REC(2) .LT. 100 ) GOTO 20
IF( REC(2) .LT.1000 ) GOTO 30
WRITE(COMPIL,44) LINE1, NM, REC(2)
IF(NL .EQ. 2)
1 WRITE(COMPIL,44) LINE2, NM, REC(2)
GOTO 900
30 WRITE(COMPIL,33) LINE1, NM, REC(2)
IF(NL .EQ. 2)
1 WRITE(COMPIL,33) LINE2, NM, REC(2)
GOTO 900
20 WRITE(COMPIL,22) LINE1, NM, REC(2)
IF(NL .EQ. 2)
1 WRITE(COMPIL,22) LINE2, NM, REC(2)
GOTO 900
10 IF( REC(2) .LT. 100 ) GOTO 2
IF( REC(2) .LT.1000 ) GOTO 3
WRITE(COMPIL,44) (REC(I), I=3,22), NM, REC(2)
GOTO 900
3 WRITE(COMPIL,33) (REC(I), I=3,22), NM, REC(2)
GOTO 900
2 WRITE(COMPIL,22) (REC(I), I=3,22), NM, REC(2)
900 RETURN
22 FORMAT( 22A4,I2 )
33 FORMAT( 21A4,A3,I3 )
44 FORMAT( 21A4,A2,I4 )
END
SUBROUTINE CORECT
C---
C--- CORRECT (PLIN) WITH (MEM) CREATING (PLTMP)
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CURRID/ IDFL
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DIMENSION SYMTB2(7,300), DIRLS2(5,500)
EQUIVALENCE ( MEM(1), SYMTB2(1,1), DIRLS2(1,1) )
DIMENSION SEQ0(2)
DATA SEQ0 / 0, 0 /
C---
IF( SHOWFL .NE. 0 ) CALL DIPRNT( -1 )
KDIRLS = NDIRLS
IDSEQ = 0
CALL RDPLIN
DO 10000 IDIRLS = 1 , NDIRLS
IF( DIRLST(5,IDIRLS) .EQ. 0 ) GOTO 10000
JDIRLS = IDIRLS
IM = DIRLST(5,JDIRLS)
1200 IC = MODLST(1,IM)
OP = CORTBL(1,IC)
IF( SHOWFL .NE. 0 ) CALL DIPRNT( 0 )
IDF = IDFL
IF( OP .NE. 11 ) GOTO 1800
C...............*AF
ISY = CORTBL(2,IC)
C....................LOOK THRU DIRLST TO FIND LAST LINE
1300 IF( SYMTB(6,ISY) .EQ. 0 ) GOTO 1310
ISY = SYMTB(6,ISY)
GOTO 1300
1310 I = SYMTB(5,ISY)
1320 IF( DIRLST(4,I) .LT. 0 ) GOTO 1330
I = DIRLST(4,I)
GOTO 1320
1330 CORTBL(2,IC) = DIRLST(1,I)
CORTBL(3,IC) = DIRLST(3,I)
1800 CORFRM = IDSEQ + 1
CALL FIND ( CORTBL(2,IC) )
IF( OP .EQ. 9 ) CALL DELET ( CORTBL(2,IC+1) )
IF( CORTBL(5,IC) .EQ. 0 ) GOTO 9000
CORSEQ = SEQ
N = CORTBL(5,IC)
NMFETC = CORTBL(4,IC)
DO 2100 I = 1 , N
CALL WTPL ( PLTMP )
CALL MEMFET
IF( TYP .LT. 3 ) GOTO 1900
AFSEQ = 0
IDF = DIRNUM
SYMTB(6,ISY) = DIRNUM
ISY = DIRNUM
1900 DIRNUM = IDF
TYP = IABS ( TYP )
IF( OP .EQ. 11 ) GOTO 1950
IDSEQ = IDSEQ + 1
SEQ = IDSEQ
GOTO 2000
1950 AFSEQ = AFSEQ + 1
SEQ = AFSEQ
2000 IF( SHOWFL .NE. 0 ) CALL DIPRNT( 2 )
2100 CONTINUE
IF( OP .EQ. 11 ) GOTO 9000
C------ MODIFY DIRLST
NEXT = DIRLST(4,JDIRLS)
KDIRLS = KDIRLS + 1
IF( KDIRLS + 1 .GT. MDIRLS ) CALL ERROR ( 20 )
DIRLST(1,KDIRLS) = IDF
DIRLST(2,KDIRLS) = CORFRM
DIRLST(3,KDIRLS) = IDSEQ
DIRLST(4,KDIRLS) = NEXT
DIRLST(5,KDIRLS) = 0
OLDTO = DIRLST(3,JDIRLS)
DIRLST(3,JDIRLS) = CORSEQ
DIRLST(4,JDIRLS) = KDIRLS
IF( OLDTO .EQ. CORSEQ ) GOTO 4000
DIRLST(4,KDIRLS) = KDIRLS + 1
KDIRLS = KDIRLS + 1
DIRLST(1,KDIRLS) = DIRLST(1,JDIRLS)
DIRLST(2,KDIRLS) = CORSEQ + 1
DIRLST(3,KDIRLS) = OLDTO
DIRLST(4,KDIRLS) = NEXT
DIRLST(5,KDIRLS) = 0
4000 CONTINUE
C......... CHANGE JDIRLS
JDIRLS = KDIRLS
9000 IM = MODLST(2,IM)
IF( IM .NE. 0 ) GOTO 1200
10000 CONTINUE
C------ COPY REST OF PLIN TO PLTMP
CALL FIND ( SEQ0 )
C------ CORRECT SYMTB
J = 0
DO 30150 I = 1 , KSYMTB
K = I
30110 J = J + 1
DO 30120 JJ = 1 , 6
30120 SYMTB2(JJ,J) = SYMTB(JJ,K)
SYMTB(7,K) = J
IF( SYMTB2(6,J) .EQ. 0 ) GOTO 30150
K = SYMTB2(6,J)
SYMTB2(6,J) = 0
GOTO 30110
30150 CONTINUE
DO 30180 I = 1 , NSYMTB
DO 30170 II = 1 , 6
30170 SYMTB(II,I) = SYMTB2(II,I)
30180 CONTINUE
NCORTB = 0
NMODLS = 0
C------ CORRECT DIRLST
J = 0
DO 30270 I = 1 , NSYMTB
IF( (SYMTB(3,I) .EQ. 0) .OR. (SYMTB(4,I) .EQ. 0) ) GOTO 30270
K = SYMTB(5,I)
SYMTB(5,I) = J + 1
30220 J = J + 1
DO 30230 JJ = 2 , 4
30230 DIRLS2(JJ,J) = DIRLST(JJ,K)
DIRLS2(5,J) = 0
II = DIRLST(1,K)
DIRLS2(1,J) = SYMTB(7,II)
IF( DIRLS2(4,J) .LT. 0 ) GOTO 30260
K = DIRLS2(4,J)
DIRLS2(4,J) = J + 1
GOTO 30220
30260 II = IABS( DIRLS2(4,J) )
DIRLS2(4,J) = -SYMTB(7,II)
30270 CONTINUE
DO 30290 I = 1 , KDIRLS
DO 30280 II = 1 , 5
30280 DIRLST(II,I) = DIRLS2(II,I)
30290 CONTINUE
NDIRLS = KDIRLS
RETURN
END
SUBROUTINE CORRD
C---
C------ READ AND PREPROCESS CORRECTION INPUT
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /COUNT/ COUNT
COMMON /CURRDK/ IXSYM , IXDIR , NCDS
COMMON /CURRID/ IDFL
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /OPTBL/ OPTBL(5,11), NOPTBL, JOP, OPARG
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DIMENSION NOID(2)
DATA NOID/ 4H.NO., 4HID. /
C---
KSYMTB = NSYMTB
NMSTOR = 0
NCORTB = 0
NMODLS = 0
CORDK = 0
ICORTB = 0
DIFL = 0
IDFL = 0
NCDS = 0
100 CALL CARDRD ( 0 )
IF( OP .NE. 0 ) GOTO 500
200 IF( DIFL .EQ. 0 ) CALL ERROR ( 22 )
220 NCDS = NCDS + 1
C......... PUT IN MEM
CALL MEMSTO
IF( IDFL .NE. 0 ) SYMTB(4,IDFL) = SYMTB(4,IDFL) + 1
IF( ICORTB .NE. 0 ) CORTBL(5,ICORTB) = CORTBL(5,ICORTB)+1
GOTO 100
500 IF( OP .EQ. 99 ) GOTO 90000
IF( (OP.EQ.1) .OR. ((OP.GE.6).AND.(OP.LE.8)) ) GOTO 520
IF( IDFL .NE. 0 ) GOTO 520
CALL ERROR ( 13 )
BKSPFL = 1
DO 510 I = 1 , 20
510 CARD4S(I) = CARD4(I)
NPLFLG = 0
ID1(1) = NOID(1)
ID1(2) = NOID(2)
GOTO 1200
520 IF( (OP.NE.9) .AND. (OP.NE.10) .AND.
1 (OP.NE.2) .AND. (OP.NE.5) ) DIFL = 0
CALL OPGET2
GOTO ( 1000, 2000, 3000, 4000, 5000, 6000, 7000, 8000
1 ,9000,10000,11000 ) , OP
C------ *ID
1000 IF( IDFL .EQ. 0 ) GOTO 1100
BKSPFL = 1
DO 1010 I = 1 , 20
1010 CARD4S(I) = CARD4(I)
GOTO 90000
1100 WRITE( OUTPUT, 1015 ) LINCNT, CARD4
1015 FORMAT( 1X,2H//,I5,1H.,20A4 )
1200 CALL SYMENT ( 0, SYMERR )
IF( SYMERR .NE. 0 ) CALL ERROR ( 99 )
NIDENT = NIDENT + 1
IDFL = ISYMTB
KSYMTB = ISYMTB
C........... TEMPORARILY DELETE ID NAME FROM SYMBOL TABLE
IDNAM1 = SYMTB(1,IDFL)
SYMTB(1,IDFL) = 0
GOTO 100
C------ *CA
2000 CALL CALINP ( CORDK, ISYM, ERR )
IF( ERR .NE. 0 ) GOTO 100
CALFLG = ISYM
GOTO 220
C------ *DK
3000 CONTINUE
C------ *CD
4000 CALL ERROR ( 14 )
C------ *WEOF, *RESEQUENCE, *PRECOMPILE, *PARTIAL
5000 GOTO 200
6000 RESEQF = 1
GOTO 100
7000 PRECOF = 1
GOTO 100
8000 FULFLG = 0
GOTO 100
C------ *D
9000 CONTINUE
C------ *I
10000 DIFL = 1
CALL SYMSRC ( ID1, ISY1 )
IF( ISY1 .EQ. 0 ) GOTO 10818
IF( ND1 .GT. IABS( SYMTB(4,ISY1) ) ) GOTO 10815
IF( OP .NE. 9 ) GOTO 10200
IF( ID2(1) .NE. BLNK ) GOTO 10100
ISY2 = ISY1
ND2 = ND1
GOTO 10200
10100 CALL SYMSRC ( ID2, ISY2 )
IF( ISY2 .EQ. 0 ) GOTO 10818
IF( ND2 .GT. IABS( SYMTB(4,ISY2) ) ) GOTO 10815
10200 NCORTB = NCORTB + 1
IF( NCORTB .GT. MCORTB ) CALL ERROR ( 16 )
ICORTB = NCORTB
CORTBL(1,NCORTB) = OP
CORTBL(2,NCORTB) = ISY1
CORTBL(3,NCORTB) = ND1
CORTBL(4,NCORTB) = NMSTOR + 1
CORTBL(5,NCORTB) = 0
IF( OP .NE. 9 ) GOTO 10300
NCORTB = NCORTB + 1
IF( NCORTB .GT. MCORTB ) CALL ERROR ( 16 )
CORTBL(1,NCORTB) = 0
CORTBL(2,NCORTB) = ISY2
CORTBL(3,NCORTB) = ND2
CORTBL(4,NCORTB) = 0
CORTBL(5,NCORTB) = 0
10300 CONTINUE
DO 10310 I = 1 , NDIRLS
IF( ISY1 .NE. DIRLST(1,I) ) GOTO 10310
IF( ND1 .LT. DIRLST(2,I) ) GOTO 10310
IF( OP .EQ. 11 ) GOTO 10320
IF( ND1 .LE. DIRLST(3,I) ) GOTO 10320
10310 CONTINUE
GOTO 10815
10320 CONTINUE
C........... SET CORDK = DK TYPE WHERE CORR IS MADE
DO 10330 II = I , NDIRLS
IF( DIRLST(4,II) .LT. 0 ) GOTO 10340
10330 CONTINUE
STOP
10340 IF( OP .NE. 11 ) GOTO 10350
ISY1 = DIRLST(1,II)
I = II
GOTO 10360
C------- PUT COMPILE FLAG IN SYMTB(4,II)
10350 II = IABS( DIRLST(4,II) )
SYMTB(4,II) = - IABS( SYMTB(4,II) )
10360 CORDK = SYMTB(3,II)
NMODLS = NMODLS + 1
IF( NMODLS .GT. MMODLS ) CALL ERROR ( 17 )
MODLST(1,NMODLS) = ICORTB
MODLST(2,NMODLS) = 0
IF( DIRLST(5,I) .GT. 0 ) GOTO 10400
DIRLST(5,I) = NMODLS
GOTO 10700
C.......... PUT THIS CORRECTION IN SORTED ORDER IN MODLST( , )
10400 MSTART = DIRLST(5,I)
M = MSTART
MOLD = 0
10440 C = MODLST(1,M)
IF( ND1 .LT. CORTBL(3,C) ) GOTO 10460
IF( MODLST(2,M) .EQ. 0 ) GOTO 10450
MOLD = M
M = MODLST(2,M)
GOTO 10440
10450 MODLST(2,M) = NMODLS
GOTO 10700
10460 IF( MOLD .NE. 0 ) GOTO 10470
DIRLST(5,I) = NMODLS
MODLST(2,NMODLS) = MSTART
GOTO 10700
10470 MODLST(2,NMODLS) = M
MODLST(2,MOLD) = NMODLS
10700 CONTINUE
GOTO 10900
10818 CALL ERROR ( 18 )
GOTO 10900
10815 CALL ERROR ( 15 )
10900 IF( OP .EQ. 11 ) GOTO 11500
GOTO 100
C------ *AF
11000 ND1 =999999
IF( ID2(1) .EQ. BLNK ) GOTO 11300
CALL SYMSRC ( ID2, ISY1 )
IF( ISY1 .EQ. 0 ) GOTO 11818
GOTO 11400
11300 ISY1 = LASTDK
11400 GOTO 10200
11500 CALL CREATE ( 0, ERRCRT )
CORTBL(5,ICORTB) = COUNT
IF( BKSPFL .NE. 0 ) GOTO 100
GOTO 90000
11818 CALL ERROR ( 18 )
GOTO 11300
C........... RESTORE ID NAME IN SYMBOL TABLE
90000 IF( IDFL .NE. 0 ) SYMTB(1,IDFL) = IDNAM1
RETURN
END
SUBROUTINE CRAK2 ( IFLD, ER1FLG )
C---
C--- COLLECT A FIELD TERMINATED BY <.>,< >,<,> IGNORING LEADING BLANKS
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
C---
DIMENSION IFLD(2)
C---
IFLD(1) = BLNK
IFLD(2) = BLNK
LEADFL = 1
J = 0
100 JCARD = JCARD + 1
IF( JCARD .GT. 80 ) GOTO 250
ICH = CARD(JCARD)
IF( ICH .NE. BLNK ) GOTO 200
IF( LEADFL .EQ. 0 ) GOTO 300
GOTO 100
200 LEADFL = 0
IF((ICH.EQ.COMA).OR.(ICH.EQ.PERD)) GOTO 300
J = J+1
IF( J .LT. 9 ) IFL(J) = ICH
GOTO 100
250 ICH = BLNK
300 IF( J .EQ. 0 ) GOTO 900
IF( (J .GT. 8) .AND. (ER1FLG .NE. 0) ) GOTO 801
IF( J .GE. 8 ) GOTO 700
J1 = J+1
DO 400 JJ = J1 , 8
400 IFL(JJ) = BLNK
700 CALL A1A4 ( IFL, IFLD, 2 )
900 RETURN
C------ ERR. FIELD GT 8 CHARS
801 CALL ERROR ( 1 )
IFLD(2) = -1
GOTO 900
END
SUBROUTINE CREATE ( OUTFIL, ERRCRT )
C---
C--- CREATE TEMPORARY NEWPL FROM SOURCE INPUT
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /COUNT/ COUNT
COMMON /CURRDK/ IXSYM , IXDIR , NCDS
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /OPTBL/ OPTBL(5,11), NOPTBL, JOP, OPARG
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
C------ PLTMP = TEMP. NEWPL FILE
C------ LINCNT = INPUT LINE COUNT
C------ NCDS = NUMBER OF CARDS IN ONE CD OR DK BLOCK
C------ DKFL = --1 FOR CD, 1 FOR DK, 0 FOR UNDEF
C---
CRTFIL = OUTFIL
ERRCRT = 0
NCDS = 0
DKFL = 0
IXSYM = 0
IXDIR = 0
COUNT = 0
C-
100 CALL CARDRD ( 1 )
IF( OP .NE. 0 ) GOTO 500
OP = 1
200 IF( DKFL .EQ. 0 ) CALL ERROR ( 3 )
NCDS = NCDS + 1
TYP = OP
DIRNUM = IXSYM
SEQ = NCDS
CALL WTPL ( CRTFIL )
COUNT = COUNT + 1
IF(IXSYM .GT. 0) SYMTB(4,IXSYM) = SYMTB(4,IXSYM)+1
IF(IXDIR .GT. 0) DIRLST(3,IXDIR) = DIRLST(3,IXDIR)+1
GOTO 100
500 IF( OP .EQ. 99 ) GOTO 9000
IF( (OUTFIL .EQ. 0) .AND. (OP .EQ. 11) ) GOTO 1000
IF( OP .GT. 7 ) GOTO 8000
IF( OP .NE. 1 ) CALL OPGET2
GOTO (1000, 2000, 3000, 3000, 5000, 6000, 7000) , OP
C------ *ID
1000 BKSPFL = 1
DO 1010 I = 1 , 20
1010 CARD4S(I) = CARD4(I)
GOTO 9000
C------ *CA
2000 CALL CALINP ( DKFL, ISYM, ERR )
IF( ERR .NE. 0 ) GOTO 100
CALFLG = ISYM
GOTO 200
C------ *DK, *CD
3000 CALL DKCDIN ( DKFL )
GOTO 200
C------ *WEOF, *RESEQUENCE, *PRECOMPILE
5000 GOTO 200
6000 RESEQF = 1
GOTO 100
7000 PRECOF = 1
GOTO 100
C------ BAD UPDATE COMMAND
8000 CALL ERROR ( 8 )
ERRCRT = 1
GOTO 100
9000 RETURN
END
SUBROUTINE DELET ( DNSQ )
C-
C--- WHILE INACTIVATING COPY PLIN TO PLTMP UNTIL DNSQ FOUND
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DIMENSION DNSQ(2)
C---
DN = DNSQ(1)
SQ = DNSQ(2)
100 TYP = -IABS ( TYP )
IF( SHOWFL .NE. 0 ) CALL DIPRNT( 1 )
IF( SQ .NE. SEQ ) GOTO 200
IF( DN .EQ. DIRNUM ) GOTO 900
200 CALL WTPL ( PLTMP )
CALL RDPLIN
GOTO 100
900 RETURN
END
SUBROUTINE DIPRNT ( IDI )
C---
C--- PRINT DELETED AND INSERTED LINES
C--- IDI =-1 PRINT HEADING, =0 PRINT SPACE
C--- =1 PRINT DELETED LINE, =2 PRINT INSERTED LINE
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DIMENSION DI(2)
DATA DI/2HD , 2H I/
C---
IF( IDI .LE. 0 ) GOTO 500
IF( IABS( TYP ) .GT. 2 ) GOTO 450
IF( CALFLG .GT. 0 ) GOTO 400
DO 302 I = 1 , 20
I2 = 21 - I
IF( CARD4(I2) .NE. BLNK ) GOTO 304
302 CONTINUE
304 CONTINUE
WRITE(OUTPUT,101) DI(IDI), SYMTB(1,DIRNUM)
. , SYMTB(2,DIRNUM), SEQ
. , (CARD4(I), I=1,I2)
C ..101 FORMAT( 1X , A2, 3H ( , 2A4, I4,3H ) 20A4 ) 8-11-86
101 FORMAT( 1X , A2, 3H ( , 2A4, I4,3H ) , 20A4 )
RETURN
400 WRITE(OUTPUT,102) DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
. , SEQ, SYMTB(1,CALFLG), SYMTB(2,CALFLG)
102 FORMAT( 1X, A2, 3H ( , 2A4, I4,7H ) *CA , 2A4 )
RETURN
450 IF( IABS( TYP ) .EQ. 3 )
. WRITE(OUTPUT,103) DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
. , SEQ, SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
103 FORMAT( 1X, A2, 3H ( , 2A4, I4,9H ) *DECK , 2A4 )
IF( IABS( TYP ) .EQ. 4 )
. WRITE(OUTPUT,104) DI(IDI), SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
. , SEQ, SYMTB(1,DIRNUM), SYMTB(2,DIRNUM)
104 FORMAT( 1X, A2, 3H ( , 2A4, I4,12H ) *COMDECK , 2A4 )
RETURN
500 IF( IDI .NE. 0 ) GOTO 600
WRITE(OUTPUT,105)
105 FORMAT( 1X )
RETURN
600 WRITE(OUTPUT,106)
106 FORMAT( //, 28H U P D A T E MODIFICATIONS )
RETURN
END
SUBROUTINE DKCDIN ( DKFL )
C-
C--- PROCESS *DK, *CD INPUT
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CURRDK/ IXSYM , IXDIR , NCDS
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
IF( OP .EQ. 4 ) GOTO 1000
C------ *DK
DKFL = 1
NDECK = NDECK + 1
GOTO 1200
C------ *CD
1000 DKFL = -1
NCOMDK = NCOMDK + 1
C------ *DK, *CD
1200 NCDS = 0
CALL SYMENT ( DKFL, SYMERR )
IXSYM = ISYMTB
NDIRLS = NDIRLS + 1
IF( NDIRLS .GT. MDIRLS ) CALL ERROR ( 20 )
IXDIR = NDIRLS
SYMTB(4,IXSYM) = 0
SYMTB(5,IXSYM) = NDIRLS
DIRLST(1,IXDIR) = IXSYM
DIRLST(2,IXDIR) = 1
DIRLST(3,IXDIR) = 0
DIRLST(4,NDIRLS) = -IXSYM
DIRLST(5,NDIRLS) = 0
RETURN
END
SUBROUTINE ERROR ( I )
C
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMPILER DEPENDENT
C---
C--- PRINT ERROR MESSAGES
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
DIMENSION XXXXXX(4)
DATA IXXXXX/200000/
C---
IF( I .EQ. 99 ) GOTO 8000
GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15
1 ,16, 17, 18, 19, 20, 21, 22, 23, 24, 25), I
1 WRITE(6,101)
101 FORMAT(13H -E R R O R--,30HFIELD LONGER THAN 8 CHARACTERS)
GOTO 9000
2 WRITE(6,102)
102 FORMAT(13H -E R R O R--,16HBAD NUMBER FIELD)
GOTO 9000
3 WRITE(6,103)
103 FORMAT(13H -E R R O R--,25H*DECK OR *COMDECK MISSING )
GOTO 8000
4 WRITE(6,104)
104 FORMAT(13H -E R R O R--,28HPERIOD MISSING BEFORE NUMBER)
GOTO 9000
5 WRITE(6,105)
105 FORMAT(13H -E R R O R--,17HNUMBER IS MISSING)
GOTO 9000
6 WRITE(6,106)
106 FORMAT(13H -E R R O R--,18HNAME IS NOT UNIQUE)
GOTO 9000
7 WRITE(6,107)
107 FORMAT(13H -E R R O R--,12HNAME MISSING)
GOTO 9000
8 WRITE(6,108)
108 FORMAT(13H -E R R O R--,25HTHIS UPDATE DIRECTIVE NOT
1 ,33H ALLOWED IN CREATION OR AFTER *AF)
GOTO 9000
9 WRITE(6,109)
109 FORMAT(13H -E R R O R--,30HCAN*T CALL FROM WITHIN COMDECK)
GOTO 9000
10 WRITE(6,110)
110 FORMAT(13H -E R R O R--,17HCOMDECK NOT FOUND)
GOTO 9000
11 WRITE(6,111)
111 FORMAT(13H -E R R O R--,17HCAN*T CALL A DECK)
GOTO 9000
12 WRITE(6,112)
112 FORMAT(13H -E R R O R--,23HCOMDECK BUFFER EXCEEDED /
1 ,13X,26HINCREASE // MEM(.), MMSTOR )
GOTO 8000
13 WRITE(6,113)
113 FORMAT(13H --WARNING---,14H*IDENT MISSING)
GOTO 7000
14 WRITE(6,114)
114 FORMAT(13H -E R R O R--,26H*DK, *CD MUST BE AFTER *AF)
GOTO 8000
15 WRITE(6,115)
115 FORMAT(13H -E R R O R--,16HNUMBER INCORRECT)
GOTO 9000
16 WRITE(6,116)
116 FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
1 ,13X,31HINCREASE // CORTBL(5,.), MCORTB)
GOTO 8000
17 WRITE(6,117)
117 FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
1 ,13X,31HINCREASE // MODLST(2,.), MMODLS)
GOTO 8000
18 WRITE(6,118)
118 FORMAT(13H -E R R O R--,25HDECK OR COMDECK NOT FOUND)
GOTO 9000
19 WRITE(6,119)
119 FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
1 ,13X,26HINCREASE // MEM(.), MMSTOR )
GOTO 8000
20 WRITE(6,120)
120 FORMAT(13H -E R R O R--,28HCORRECTION CAPACITY EXCEEDED /
1 ,13X,31HINCREASE // DIRLST(5,.), MDIRLS )
GOTO 8000
21 WRITE(6,121)
121 FORMAT(13H -E R R O R--,28HOVERLAPPING CORRECTION FOUND )
GOTO 8000
22 WRITE(6,122)
122 FORMAT(13H -E R R O R--,19H*D, *I, *AF MISSING)
GOTO 9000
23 WRITE(6,123)
123 FORMAT(13H -E R R O R--,17HCOMDECK NOT FOUND)
GOTO 9000
24 WRITE(6,124)
124 FORMAT(13H -E R R O R--)
RETURN
25 WRITE(6,125)
125 FORMAT(13H -E R R O R--)
RETURN
7000 WARNFL = 1
RETURN
8000 WRITE( 6, 1003 )
1003 FORMAT( 18H ? *** ABORTED *** )
C>>>>>>>>> *ABORT* <<<<<<<<<<
C... TYPE 1003 8-11-86
PRINT 1003
I = XXXXXX(IXXXXX)
9000 ERRFLG = 1
RETURN
END
SUBROUTINE FIND ( DNSQ )
C-
C--- COPY PLIN TO PLTMP UNTIL DNSQ FOUND
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DIMENSION DNSQ(2)
C---
DN = DNSQ(1)
SQ = DNSQ(2)
DIRNUX = DIRNUM
SEQX = SEQ
100 IF( SQ .NE. SEQ ) GOTO 200
IF( DN .EQ. DIRNUM ) GOTO 900
200 CALL WTPL ( PLTMP )
CALL RDPLIN
IF( SEQ .NE. 0 ) GOTO 100
IF( SQ .NE. 0 ) WRITE( OUTPUT, 101 ) SYMTB(1,DIRNUX),
1 SYMTB(2,DIRNUX), SEQX
2 , SYMTB(1,DN), SYMTB(2,DN), SQ
101 FORMAT( 28H ------------- NOW AT LINE= , 2A4, I4,
1 22H LOOKING FOR LINE= , 2A4, I4 )
IF( SQ .NE. 0 ) CALL ERROR ( 21 )
900 RETURN
END
FUNCTION ISRCH(KEY,KEYLST,NKEY,NDIM)
C
C SEARCH KEYLST(NDIM,NKEY) FOR KEY(NDIM)
C
DIMENSION KEY(1), KEYLST(1)
C
C SET TOP AND BOTTOM OF RANGE
ITOP = NKEY
IBOT = 0
ISRCH = 0
C PRINT 902, (KEY(I),I=1,4)
C 902 FORMAT(* LOOKING FOR *4A4)
C DIVIDE SEARCH RANGE IN TWO
5 IHLF = (ITOP+IBOT)/2
C PRINT 901,ITOP,IBOT,IHLF
C 901 FORMAT(1H ,*ITOP = *I4* IBOT = *I4* IHLF = *I4)
C PRINT 903, (KEYLST(I+(IHLF-1)*NDIM),I=1,4)
C 903 FORMAT(* COMPARING WITH *4A4)
C COMPARE KEY(I) WITH KEYLST(I,IHLF)
DO 10 I=1,NDIM
I1 = I + (IHLF-1)*NDIM
IF( KEY(I) .GT. KEYLST(I1) ) GOTO 40
IF( KEY(I) .LT. KEYLST(I1) ) GOTO 60
10 CONTINUE
C EQUAL. SET ISRCH AND RETURN
ISRCH = IHLF
GO TO 100
C KEY IS IN TOP HALF. CHECK FOR NOT FOUND
40 CONTINUE
IF (ITOP .EQ. IBOT) GO TO 100
C RESET IBOT AND KEEP GOING
IBOT = IHLF + 1
GO TO 5
C KEY IS IN BOTTOM HALF. CHECK FOR NOT FOUND
60 CONTINUE
IF (ITOP .EQ. IBOT) GO TO 100
C RESET ITOP AND KEEP GOING
ITOP = IHLF
GO TO 5
100 CONTINUE
RETURN
END
SUBROUTINE MEMFET
C-
C--- FETCH A CARD FROM MEM TO REC ARRAY
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
CALFLG = 0
TYP = MEM(NMFETC)
IF( TYP .NE. 1 ) GOTO 330
DO 320 I = 1 , 20
IM = NMFETC + I
320 REC(I+2) = MEM(IM)
NMFETC = NMFETC + 21
GOTO 900
330 IF( TYP .NE. 2 ) GOTO 340
CALFLG = MEM(NMFETC+1)
NMFETC = NMFETC + 2
GOTO 900
340 DIRNUM=MEM(NMFETC+1)
NMFETC = NMFETC + 2
900 RETURN
END
SUBROUTINE MEMSTO
C-
C--- STORE CORRECTION CARDS IN MEMORY
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
IF( NMSTOR+21 .GT. MMEM ) CALL ERROR ( 19 )
MEM(NMSTOR+1) = TYP
IF( TYP .NE. 1 ) GOTO 330
DO 320 I = 1 , 20
IM = NMSTOR + I
MEM(IM+1) = CARD4(I)
320 CONTINUE
NMSTOR = NMSTOR + 21
GOTO 390
330 IF( TYP .NE. 2 ) GOTO 340
MEM(NMSTOR+2) = CALFLG
NMSTOR = NMSTOR+2
GOTO 390
340 MEM(NMSTOR+2) = DIRNUM
NMSTOR = NMSTOR + 2
390 RETURN
END
SUBROUTINE NUMCOL ( NUM )
C---
C--- COLLECT NUMBER FIELD TERMINATED BY <,>,< >
C---
IMPLICIT INTEGER (A-Z)
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
C---
DIMENSION N09(10)
C---
DATA N09/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C---
NUM = 0
IF( (JCARD.GE.80).OR.(ICH.NE.PERD)) GOTO 800
100 JCARD = JCARD + 1
IF( JCARD .GT. 80 ) GOTO 250
ICH = CARD(JCARD)
IF( (ICH.EQ.BLNK).OR.(ICH.EQ.COMA) ) GOTO 300
C------ CK IF NUMBER
DO 220 I = 1 , 10
IF( ICH .EQ. N09(I) ) GOTO 230
220 CONTINUE
CALL ERROR ( 2 )
GOTO 900
230 NUM = 10*NUM + I-1
GOTO 100
250 ICH = BLNK
300 CONTINUE
C------ GIVE ERROR MSG IF NUMBER IS MISSING
IF( NUM .EQ. 0 ) CALL ERROR ( 5 )
RETURN
C------ PERIOD MISSING BEFORE NUMBER
800 CALL ERROR ( 4 )
900 RETURN
END
SUBROUTINE OPGET
C---
C--- SCAN OP FIELD AND GET OP NUMBER
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /OPTBL/ OPTBL(5,11), NOPTBL, JOP, OPARG
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
DIMENSION IFLD(2)
C---
JCARD = 1
CALL CRAK2 ( IFLD, 0 )
OP = 0
IF( IFLD(1) .EQ. BLNK ) GOTO 900
DO 200 I = 1 , NOPTBL
IF( (IFLD(1).EQ.OPTBL(1,I)).OR.
1 (IFLD(1).EQ.OPTBL(2,I)) ) GOTO 300
200 CONTINUE
GOTO 900
300 OP = OPTBL(4,I)
OPARG = OPTBL(5,I)
JOP = I
900 RETURN
END
SUBROUTINE OPGET2
C---
C--- GET THE TWO OPERANDS OF UPDATE COMMAND
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CARD/ CARD(80), JCARD, LINCNT, PRTFLG, ICH
1 ,IFL(8) , BKSPFL
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /OPTBL/ OPTBL(5,11), NOPTBL, JOP, OPARG
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
DIMENSION N09(10)
C---
DATA N09/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C---
IF( OPARG .EQ. 0 ) GOTO 900
IOPARG = IABS(OPARG)
SOPARG = OPARG / IOPARG
CALL CRAK2 ( ID1, 1 )
IF( SOPARG .LT. 0 ) CALL NUMCOL ( ND1 )
IF( IOPARG .EQ. 1 ) GOTO 600
IF( ICH .NE. COMA ) GOTO 600
CALL CRAK2 ( ID2, 1 )
IF( SOPARG .GE. 0 ) GOTO 900
DO 300 I = 1 , 10
IF( IFL(1) .EQ. N09(I) ) GOTO 400
300 CONTINUE
GOTO 500
400 DO 420 I = 1 , 8
CARD(I+71) = IFL(I)
420 CONTINUE
CARD(80) = BLNK
JCARD = 71
ICH = PERD
ID2(1) = ID1(1)
ID2(2) = ID1(2)
500 CALL NUMCOL ( ND2 )
GOTO 900
600 ID2(1) = BLNK
ND2 = -1
900 RETURN
END
SUBROUTINE OPLRD
C---
C--- READ OLDPL DIRECTORY
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
C---
READ(OLDPL ,1010) NCOMDK, NDECK, NIDENT, NDIRLS
1010 FORMAT( 3X,I4,3X,I4,3X,I4,3X,I4 )
NSYMTB = NCOMDK + NDECK + NIDENT
READ(OLDPL ,1007) ((SYMTB(I,J), I=1,5), J=1,NSYMTB)
1007 FORMAT( 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4,
1 1X,2A4,I2,I5,I4 )
READ(OLDPL ,1008) ((DIRLST(I,J), I=1,3), J=1,NDIRLS)
1008 FORMAT( I4,2I5, I4,2I5, I4,2I5, I4,2I5, I4,2I5 )
C------
DO 100 I = 1 , NSYMTB
IF( IABS( SYMTB(3,I) ) .EQ. 1 ) LASTDK = I
SYMTB(6,I) = 0
SYMTB(7,I) = I
100 CONTINUE
C------ FILL THE BACK POINTER IN DIRLST
DO 200 I = 1 , NDIRLS
DIRLST(4,I) = 0
DIRLST(5,I) = 0
200 CONTINUE
IF( NSYMTB .LT. 2 ) GOTO 350
DO 300 I = 2 , NSYMTB
J = SYMTB(5,I)
DIRLST(4,J-1) = -(I-1)
300 CONTINUE
350 DIRLST(4,NDIRLS) = - LASTDK
C------ FILL NEXT ENTRIES IN DIRLST
DO 400 I = 1 , NDIRLS
IF( DIRLST(4,I) .EQ. 0 ) DIRLST(4,I) = I+1
400 CONTINUE
C------
RETURN
END
SUBROUTINE PRECMP(REC,LINE1,LINE2,NL)
C
C PRGEDT EDITS SOURCE FILES, REPLACING NAMES WITHIN<> WITH A
C POSITION IN THE LINE.
C
C IA CONTAINS THE INPUT LINE
C IB CONTAINS THE OUTPUT LINE
C ID SAVES COLUMNS 73-90 OF IA
C ICA STORES THE PRESENT POSITION IN IA
C ICB STORES THE PRESENT POSITION IN IB
C
IMPLICIT INTEGER (A-Z)
C
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
C
DIMENSION NAME(2),REC(20),LINE1(20),LINE2(20),CARD(80)
DIMENSION IA(80), IB(144), INAM(4,1500), ITXT(4,1500),
1 KEY(16), KEY4(4), IREPL(16), ID( 8), IB2(72), IREPL2(20)
C
EQUIVALENCE (IA(1), CARD(1)), (IB2(1), IB(1))
C
DATA NENTS/0/
DATA ITERMB, ITERME, ICMNT, ICNTNU, IBLNK /
1 1H<, 1H>, 1HC, 1H., 1H /
DATA IHI, IAT, IRP / 1HI, 1H@, 1H) /
DATA IREPL2(2), IREPL2(3), IREPL2(4)
1 / 1HA, 1H(, 1HI /
C
C
IF ( NENTS .GT. 0) GO TO 1
C
C I N I T I A L I Z A T I O N
C
IERR = 0
REWIND EDTT
C INITIALIZE START OF OVERFLOW LINE
DO 5 I = 73,77
5 IB(I) = IBLNK
IB(78) = ICNTNU
C READ IN EDIT TABLE
READ(EDTT, END=90000) NENTS, ((INAM(I,J), I=1,4), J=1,NENTS),
1 ((ITXT(I,J),I=1,4),J=1,NENTS)
REWIND EDTT
C
1 CONTINUE
LINE1(19) = IBLNK
LINE1(20) = IBLNK
LINE2(19) = IBLNK
LINE2(20) = IBLNK
CALL A4A1(REC,CARD,20)
IF(IA(1) .NE. ICMNT) GOTO 3
NL = 1
DO 4 I=1,20
4 LINE1(I) = REC(I)
RETURN
3 J = 0
DO 2 I = 73, 80
J = J + 1
ID(J) = IA(I)
2 CONTINUE
C
C LOOP THROUGH IA LOOKING FOR <
20 ICA = 0
ICB = 0
C BLANK OUT IB
DO 25 I=1,72
25 IB(I) = IBLNK
DO 26 I=79,144
26 IB(I) = IBLNK
30 ICA = ICA + 1
IF (ICA .EQ. 73) GO TO 100
IF (IA(ICA) .EQ.ITERMB) GO TO 200
C DID NOT FIND < --- SET IB = IA
ICB = ICB + 1
C CHECK FOR OVERFLOW
IF (ICB .EQ. 73) ICB = ICB + 6
IB(ICB) = IA(ICA)
GO TO 30
C END OF LINE. CHECK FOR NUM OF LINES AND RETURN
C
100 NL = 1
DO 111 I=79,144
IF(IB(I) .NE. IBLNK) NL = 2
111 CONTINUE
CALL A1A4(IB,LINE1,18)
IF(NL .EQ. 2) CALL A1A4(IB(73),LINE2,18)
RETURN
C
C FOUND <. LOOP THROUGH IA LOOKING FOR >
200 KYC = 0
IATFLG = 0
C CHECK FOR AT SIGN
IF (IA(ICA+1) .NE. IAT) GO TO 210
ICA = ICA + 1
IATFLG = 1
210 ICA = ICA + 1
KYC = KYC + 1
C IF ICA GREATER THAN 72 --- ERROR
IF (ICA .GT. 72) GO TO 700
C IF KYC GREATER THAN 16 --- ERROR
IF (IA(ICA) .EQ. ITERME) GO TO 220
IF (KYC .GT. 16) GO TO 710
C SET KEY
KEY(KYC) = IA(ICA)
GO TO 210
220 CONTINUE
C FOUND > . ZERO OUT REST OF KEY
IF(KYC .GT. 16) GOTO 2002
DO 225 I=KYC,16
225 KEY(I) = IBLNK
2002 CONTINUE
C ENCODE KEY ONTO KEY4 USING A4 FORMAT
CALL A1A4(KEY,KEY4,4)
C SEARCH FOR KEY4 IN INAM
IX = ISRCH(KEY4,INAM,NENTS,4)
C COULD NOT FIND --- ERROR
IF (IX .EQ. 0) GO TO 720
C MOVE THE REPLACEMENT TEXT INTO IREPL IN A1 FORMAT
CALL A4A1(ITXT(1,IX),IREPL,4)
C CHECK FOR AT SIGN
IF (IATFLG .EQ. 0) GO TO 229
C THERE WAS AN AT SIGN. FILL IREPL2
IREPL2(1) = IREPL(1)
DO 226 I=2,14
226 IREPL2(I+3) = IREPL(I)
C MOVE IREPL2 INTO IB, LEAVING OFF TRAILING ZEROS
DO 227 I=1,18
IF( IREPL2(I) .EQ. IBLNK ) GOTO 228
ICB = ICB + 1
IF (ICB .EQ. 73) ICB = ICB + 6
227 IB(ICB) = IREPL2(I)
GO TO 30
228 ICB = ICB + 1
IF (ICB .EQ. 73) ICB = ICB + 6
IB(ICB) = IRP
GO TO 30
229 CONTINUE
C MOVE IREPL INTO IB, LEAVING OFF THE TRAILING ZEROS
DO 230 I=1,14
IF( IREPL(I) .EQ. IBLNK ) GOTO 30
ICB = ICB + 1
IF (ICB .EQ. 73) ICB = ICB + 6
230 IB(ICB) = IREPL(I)
C CONTINUE LOOPING THROUGH IA
GO TO 30
C ERROR PROCESSING
700 CONTINUE
1001 FORMAT ( 80A1)
WRITE ( OUTPUT, 701) IA
701 FORMAT(1H ,46HERROR --- FOUND END OF LINE BEFORE>. THE LINE
1, 9H WAS --- /1H ,90A1/)
IERR = 1
WRITE (OUTPUT,1001) IA
GO TO 10
710 CONTINUE
WRITE ( OUTPUT, 711) KEY, IA
711 FORMAT(1H ,52HERROR --- NAME WITHIN <> GREATER THAN 16 CHARACTERS.
1,14HTHE NAME IS - ,16A1,16H THE LINE IS - /1H ,90A1/)
IERR = 1
WRITE (OUTPUT,1001) IA
GO TO 10
720 CONTINUE
WRITE ( OUTPUT, 721) KEY, IA
721 FORMAT(1H ,41HERROR --- NAME NOT FOUND IN EDIT TABLE.
1,14HTHE NAME IS - ,16A1,16H THE LINE IS - /1H ,90A1/)
IERR = 1
ICABS = ICA - KYC - IATFLG
DO 724 I=ICABS,ICA
ICB = ICB + 1
IF (ICB .EQ. 73) ICB = ICB + 6
IB(ICB) = IA(I)
724 CONTINUE
GO TO 30
90000 WRITE(OUTPUT,90001)
90001 FORMAT( 40H ***ERROR*** (UPDATE) FILE EDTT MISSING )
PRECOF = 0
10 RETURN
END
SUBROUTINE RDPLIN
C
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMPILER DEPENDENT
C-
C--- READ ONE LINE FROM PLIN
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /DKFLG/ DKFLG
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
C>>>>>>>>> *EOF* <<<<<<<<<
READ( PLIN, 1009, END=800 ) TYP, REC
1009 FORMAT( I2,I4,I5,1X,20A4 )
DIRNUM = SYMTB(7,DIRNUM)
IF( TYP .EQ. 3 ) DKFLG = DIRNUM
CALFLG = 0
IF( IABS( TYP ) .NE. 2 ) GOTO 900
READ( PLIN, 1014 ) CALFLG
1014 FORMAT( 4X,I4 )
CALFLG = SYMTB(7,CALFLG)
IF( DKFLG .EQ. 0 ) GOTO 900
IF( SYMTB(4,CALFLG) .LT. 0 )
1 SYMTB(4,DKFLG) = - IABS( SYMTB(4,DKFLG) )
900 RETURN
800 SEQ = 0
GOTO 900
END
SUBROUTINE RESEQ
C---
C------ RESEQUENCE (PLIN) INTO (PLTMP)
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /DKFLG/ DKFLG
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
C------ DISABLE COMPILE FLAG SETTING PART IN RDPLIN
DKFLG = 0
NDIRLS = 0
200 CALL RDPLIN
IF( SEQ .EQ. 0 ) GOTO 900
ITYP = IABS ( TYP )
GOTO ( 12, 12, 34, 34 ), ITYP
C------ *CA, DATA
12 IF( TYP .LT. 0 ) GOTO 200
300 NEWSEQ = NEWSEQ + 1
SEQ = NEWSEQ
SYMTB(4,JSYMTB) = NEWSEQ
DIRLST(3,NDIRLS) = NEWSEQ
DIRNUM = JSYMTB
CALL WTPL ( PLTMP )
GOTO 200
C------ *CD, *DK
34 NEWSEQ = 0
JSYMTB = DIRNUM
NDIRLS = NDIRLS + 1
DIRLST(1,NDIRLS) = JSYMTB
DIRLST(2,NDIRLS) = 1
DIRLST(3,NDIRLS) = 1
DIRLST(4,NDIRLS) = -JSYMTB
GOTO 300
C------ EOF ON PLIN
900 NSYMTB = JSYMTB
DO 920 I = 1 , NSYMTB
SYMTB(7,I) = I
920 CONTINUE
RETURN
END
SUBROUTINE SYMENT ( SYMTYP, SYMERR )
C---
C--- ENTER SYMBOL IN SYMBOL TABLE
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /OP/ IOP(2), ID1(2), ND1, ID2(2), ND2, NOP, OP
C---
SYMERR = 0
IF( ID1(2) .EQ. -1 ) GOTO 850
IF( ID1(1) .EQ. BLNK ) GOTO 8007
C------ SEARCH SYMBOL TABLE
IF( NSYMTB .EQ. 0 ) GOTO 300
DO 200 I = 1 , NSYMTB
IF( ID1(1) .NE. SYMTB(1,I) ) GOTO 200
IF( ID1(2) .EQ. SYMTB(2,I) ) GOTO 8006
200 CONTINUE
300 NSYMTB = NSYMTB + 1
ISYMTB = NSYMTB
SYMTB(1,NSYMTB) = ID1(1)
SYMTB(2,NSYMTB) = ID1(2)
SYMTB(3,NSYMTB) = SYMTYP
SYMTB(4,NSYMTB) = 0
SYMTB(5,NSYMTB) = 0
SYMTB(6,NSYMTB) = 0
SYMTB(7,NSYMTB) = NSYMTB
GOTO 900
C------ NAME IS NOT UNIQUE
8006 CALL ERROR ( 6 )
SYMERR = 1
GOTO 880
C------ NAME MISSING
8007 CALL ERROR ( 7 )
850 SYMERR = 2
880 ISYMTB = 0
900 RETURN
END
SUBROUTINE SYMSRC ( SYM, ISYM )
C---
C--- SEARCH SYMBOL TABLE FOR SYM(1-2)
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
C---
DIMENSION SYM(2)
C---
IF( NSYMTB .EQ. 0 ) GOTO 800
DO 200 I = 1 , NSYMTB
IF( SYM(1) .NE. SYMTB(1,I) ) GOTO 200
IF( SYM(2) .EQ. SYMTB(2,I) ) GOTO 400
200 CONTINUE
800 I = 0
400 ISYM = I
RETURN
END
SUBROUTINE WNEWPL
C---
C------ WRITE NEWPL AND COMPILE FILES
C---
IMPLICIT INTEGER (A-Z)
C---
COMMON /DIR/ MSYMTB, NSYMTB, KSYMTB, ISYMTB
1 , MDIRLS, NDIRLS, KDIRLS, IDIRLS
2 , NCOMDK, NDECK , NIDENT
3 , MMEM , NMSTOR, NMFETC
4 , MCORTB, NCORTB, MMODLS, NMODLS
5 , LASTDK
COMMON SYMTB(7,400) , DIRLST(5,2000)
1 , CORTBL(5,1000), MODLST(2,1000)
2 , MEM(20000)
COMMON /DKFLG/ DKFLG
COMMON /FILES/ INPUT , OUTPUT, OLDPL , NEWPL , COMPIL
1 , EDTT , PL1TMP, PL2TMP, PLTMP , PLIN
COMMON /FLAGS/ FULFLG, RESEQF, PRECOF, NPLFLG, ERRFLG
9 , WARNFL, SHOWFL
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
DIMENSION CDIDDK(3)
DATA CDIDDK/2HCD, 2HID, 2HDK/
C------ DISABLE COMPILE FLAG SETTING IN RDPLIN
DKFLG = 0
REWIND COMPIL
C---
IF( NPLFLG .EQ. 1 ) NPLFLG = FULFLG
IF( (ERRFLG + WARNFL) .NE. 0 ) NPLFLG = 0
C---
NMSTOR = 0
IF( NPLFLG .NE. 0 ) REWIND NEWPL
IF( NPLFLG .NE. 0 )
1 WRITE(NEWPL ,1006) NCOMDK, NDECK, NIDENT, NDIRLS
1006 FORMAT( 10H DIRECTORY,/,3H CD,I4,3H DK,I4,3H ID,I4,3H LM,I4 )
DO 110 I = 1 , NSYMTB
SYMTB(6,I) = SYMTB(4,I)
SYMTB(4,I) = IABS ( SYMTB(4,I) )
110 CONTINUE
IF( NPLFLG .NE. 0 )
1 WRITE(NEWPL ,1007) ((SYMTB(I,J), I=1,5), J=1,NSYMTB)
1007 FORMAT( 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4, 1X,2A4,I2,I5,I4,
1 1X,2A4,I2,I5,I4 )
DO 120 I = 1 , NSYMTB
SYMTB(5,I) = SYMTB(3,I)
J = SYMTB(3,I)
SYMTB(3,I) = CDIDDK(J+2)
120 CONTINUE
WRITE(OUTPUT,1019) NCOMDK, NDECK, NIDENT
1019 FORMAT( 10H DIRECTORY,/,1X,I4,10H COMDECKS,,I5,7H DECKS,
1 ,I5,7H IDENTS)
WRITE(OUTPUT,1018) ((SYMTB(I,J), I=1,4), J=1,NSYMTB)
1018 FORMAT( 1X,2A4,2X,A2,I5, 5X,2A4,2X,A2,I5
1 , 5X,2A4,2X,A2,I5, 5X,2A4,2X,A2,I5 )
IF( NPLFLG .NE. 0 )
1 WRITE(NEWPL ,1008) ((DIRLST(I,J), I=1,3), J=1,NDIRLS)
1008 FORMAT( I4,2I5, I4,2I5, I4,2I5, I4,2I5, I4,2I5 )
C---
DO 200 I = 1 , NSYMTB
SYMTB(3,I) = SYMTB(5,I)
SYMTB(4,I) = SYMTB(6,I)
SYMTB(5,I) = 0
200 SYMTB(6,I) = 0
C------ TRANSFER PLIN TO NEWPL
2000 CALL RDPLIN
IF( SEQ .EQ. 0 ) GOTO 9000
IF( NPLFLG .NE. 0 )
1 CALL WTPL ( NEWPL )
C.......... DO NOTHING IF INACTIVE
IF( TYP .LT. 0 ) GOTO 2000
GOTO (2100, 2200, 2300, 2400, 2500) , TYP
C------ DATA
2100 IF( CDFLG .NE. 0 ) GOTO 2150
IF( CFFL .NE. 0 ) CALL COMPWT ( REC )
GOTO 2000
2150 IF( NMSTOR+22 .GT. MMEM ) CALL ERROR ( 12 )
SYMTB(6,CDFLG) = SYMTB(6,CDFLG) + 1
DO 2160 I = 1 , 22
II = NMSTOR + I
2160 MEM(II) = REC(I)
NMSTOR = NMSTOR + 22
GOTO 2000
C------ *CA
2200 IF( CFFL .EQ. 0 ) GOTO 2000
PTR = SYMTB(5,CALFLG)
N = SYMTB(6,CALFLG)
IF( PTR .EQ. 0 ) GOTO 2280
IF( N .EQ. 0 ) GOTO 2000
DO 2220 I = 1 , N
CALL COMPWT ( MEM(PTR) )
PTR = PTR + 22
2220 CONTINUE
GOTO 2000
2280 CALL ERROR ( 23 )
WRITE( OUTPUT, 1017 ) (SYMTB(I,CALFLG), I=1,2)
1017 FORMAT(13X,8HCOMDECK ,2A4,27H MUST BE PREVIOUSLY DEFINED)
GOTO 2000
C------ *DK
2300 CDFLG = 0
CFFL = FULFLG
IF( SYMTB(4,DIRNUM) .LT. 0 ) CFFL = CFFL + 1
GOTO 2000
C------ *CD
2400 CDFLG = DIRNUM
SYMTB(5,CDFLG) = NMSTOR + 1
SYMTB(6,CDFLG) = 0
GOTO 2000
C------ *WEOF
2500 ENDFILE COMPIL
GOTO 2000
C------ END OF (PLIN)
9000 ENDFILE COMPIL
REWIND PLIN
REWIND COMPIL
ENDFILE PLIN
REWIND PLIN
IF( NPLFLG .NE. 0 ) ENDFILE NEWPL
IF( NPLFLG .NE. 0 ) REWIND NEWPL
IF( ERRFLG .EQ. 0 ) GOTO 9900
ENDFILE COMPIL
REWIND COMPIL
IF( NPLFLG .EQ. 0 ) GOTO 9900
ENDFILE NEWPL
REWIND NEWPL
9900 RETURN
END
SUBROUTINE WTPL ( LFN )
C-
C--- WRITE ONE PL LINE TO LFN, IF LFN=0 WRITE INTO MEM ARRAY
C-
IMPLICIT INTEGER (A-Z)
C---
COMMON /CHARS/ STAR, BLNK, COMA, PERD, SLAS
COMMON /REC/ CALFLG, TYP, DIRNUM, SEQ, CARD4(20)
1 , CARD4S(20)
DIMENSION REC(22)
EQUIVALENCE (DIRNUM, REC(1))
C---
1004 FORMAT( I2,I4,I5 )
1005 FORMAT( I2,I4,I5,/,4X,I4 )
1009 FORMAT( I2,I4,I5,1X,20A4 )
C---
IF( LFN .EQ. 0 ) GOTO 300
IF( CALFLG .EQ. 0 ) GOTO 200
WRITE( LFN, 1005 ) TYP, DIRNUM, SEQ, CALFLG
GOTO 900
200 IF( IABS( TYP ) .NE. 1 ) GOTO 220
DO 202 I = 1 , 20
I2 = 23 - I
IF( REC(I2) .NE. BLNK ) GOTO 204
202 CONTINUE
204 WRITE( LFN, 1009 ) TYP, ( REC(I), I=1,I2 )
GOTO 900
220 WRITE( LFN, 1004 ) TYP, DIRNUM, SEQ
GOTO 900
300 CALL MEMSTO
900 RETURN
END